【Excel VBA 再利用コード集】シフト表作成の基礎となる割当ロジック（辞書＋配列）

Dom_AssignTanmu
└─ CreateTanmuWs（担務表へ担当者を割り当てるメイン処理）
   ├─ Dom_CreateDic
   │  └─ CreateShiftWariateDic（シフト名→可スタッフ辞書を作成）
   │     └─ Util_GetArray
   │        ├─ GetUsedRangeArray（シートの使用範囲を配列で取得）
   │        └─ DebugPrintArraySize（配列サイズをデバッグ出力）
   │
   ├─ Util_GetArray
   │  ├─ GetUsedRangeArray（シートの使用範囲を配列で取得）
   │  └─ DebugPrintArraySize（配列サイズをデバッグ出力）
   │
   ├─ Util_ShuffleElements
   │  └─ ShuffleArrayByFisherYates（候補者配列をランダムに並び替え）
   │
   └─ GetMatsubiBangou（担当者名の末尾番号を抽出）

Option Explicit


Public Sub CreateTanmuSheet()

    ' Description
    '   シフト割当表から作成した「シフト名→可スタッフ辞書」を参照し、
    '   担務表の各日付×各シフトの未割当セルへ担当者名を割り当てる。
    '   候補者はシャッフルし、先頭要素を採用する（追加制約は一切入れない）。
    '
    ' Arguments
    '   (None)
    '
    ' Returns
    '   なし


    ' 固定仕様（担務表）
    Const TANMU_SHEET_NAME       As String = "担務表"
    Const TANMU_SHIFT_NAME_COL   As Long = 1   ' A列
    Const TANMU_DATE_ROW         As Long = 1   ' 1行目
    Const TANMU_DATA_START_ROW   As Long = 3   ' 3行目
    Const TANMU_DATE_START_COL   As Long = 2   ' B列


    ' 担務表・シフト割当辞書の取得
    '--------------------------------------------------------------------------
    ' 担務表シートの取得
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets(TANMU_SHEET_NAME)
    
    ' 担務表配列の取得
    Dim tanmu_tbl As Variant
    tanmu_tbl = GetUsedRangeArray(ws)
    Call DebugPrintArraySize(tanmu_tbl, "担務表配列")
    If IsEmpty(tanmu_tbl) Then Exit Sub
    
    ' シフト割当辞書の取得
    Dim staff_shift_kahi_dic As Scripting.Dictionary
    Set staff_shift_kahi_dic = CreateShiftWariateDic()
    If staff_shift_kahi_dic Is Nothing Then Exit Sub


    ' 割当処理（日付列×担務行を走査）
    '--------------------------------------------------------------------------
    Dim assign_count As Long
    assign_count = 0
    
    ' 担務表配列の列方向を走査
    Dim date_col As Long
    For date_col = TANMU_DATE_START_COL To UBound(tanmu_tbl, 2)

        ' 日付セルが空の列はスキップ（列の終端対策）
        Dim date_val As String
        date_val = Trim$(CStr(tanmu_tbl(TANMU_DATE_ROW, date_col)))
        If Len(date_val) = 0 Then GoTo NextDateCol
        
        ' 担務表配列の行方向を走査
        Dim tanmu_row As Long
        For tanmu_row = TANMU_DATA_START_ROW To UBound(tanmu_tbl, 1)

            ' 担務表からシフト名を取得（空欄は対象外）
            Dim shift_name As String
            shift_name = Trim$(CStr(tanmu_tbl(tanmu_row, TANMU_SHIFT_NAME_COL)))
            If Len(shift_name) = 0 Then GoTo NextTanmuRow

            ' 既に値が入っているセルは変更しない
            Dim cell_value As String
            cell_value = Trim$(CStr(tanmu_tbl(tanmu_row, date_col)))
            If Len(cell_value) > 0 Then GoTo NextTanmuRow

            ' 辞書にシフト名が存在しない場合はスキップ
            If Not staff_shift_kahi_dic.Exists(shift_name) Then GoTo NextTanmuRow
            
            ' 対象シフトに割り当て可能なスタッフ辞書を取得（取得できない場合はスキップ）
            Dim assignable_staff_dic As Scripting.Dictionary
            Set assignable_staff_dic = staff_shift_kahi_dic(shift_name)
            If assignable_staff_dic Is Nothing Then GoTo NextTanmuRow
            
            ' 可スタッフが存在しない場合は割当対象外
            Dim staff_count As Long    ' 割り当て可能なスタッフの人数
            staff_count = assignable_staff_dic.Count
            If staff_count = 0 Then GoTo NextTanmuRow

            ' 可スタッフ辞書のキー（スタッフ名一覧）を配列として取得
            Dim temp_keys As Variant
            temp_keys = assignable_staff_dic.Keys
            
            ' スタッフリスト配列を1始まりで定義
            Dim staff_list() As Variant
            ReDim staff_list(1 To staff_count)
            
            ' 1始まりのスタッフ配列に詰め替え
            Dim idx As Long
            For idx = 1 To staff_count
                staff_list(idx) = temp_keys(idx - 1)
            Next idx

            ' 候補者をシャッフルしたリストを取得
            Dim shuffled_list As Variant
            shuffled_list = ShuffleArrayByFisherYates(staff_list, staff_count)
            
            ' シャッフルしたリストの先頭の候補者を取得
            Dim assign_person As String
            assign_person = Trim$(CStr(shuffled_list(1)))
            
            ' 候補者が0人でなければ
            If Len(assign_person) > 0 Then
                ' 担務表配列に書き込み
                ' 担当者名の末尾番号のみを書き込む
                tanmu_tbl(tanmu_row, date_col) = _
                    "従" & GetMatsubiBangou(assign_person)
                assign_count = assign_count + 1
            End If

NextTanmuRow:
        Next tanmu_row

NextDateCol:
    Next date_col


    ' 担務表シートに書き戻し
    '--------------------------------------------------------------------------
    ws.Range( _
        ws.Cells(1, 1), _
        ws.Cells(UBound(tanmu_tbl, 1), UBound(tanmu_tbl, 2)) _
    ).Value = tanmu_tbl

    Debug.Print "担務表 割当 件数 = " & assign_count

End Sub


' 補助関数
' -----------------------------------------------------------------------------
Function GetMatsubiBangou(ByVal src As String) As String

    ' Description
    '   文字列の末尾に連続して付いている番号のみを抽出して返す。
    '   末尾に番号が存在しない場合は空文字を返す。
    '
    ' Arguments
    '   src : 元となる文字列
    '
    ' Returns
    '   末尾の連続した番号文字列


    ' 後ろから走査するためのインデックス
    Dim i As Long

    ' 抽出した番号を格納する文字列
    Dim result As String
    result = ""

    ' 文字列を末尾から先頭へ向かって走査
    For i = Len(src) To 1 Step -1

        ' 数字であれば結果文字列の先頭に連結
        If Mid$(src, i, 1) Like "[0-9]" Then
            result = Mid$(src, i, 1) & result

        ' 数字以外が出た時点で走査を終了
        Else
            Exit For
        End If

    Next i

    ' 抽出した末尾番号を返す
    GetMatsubiBangou = result

End Function

Option Explicit


Public Sub DebugPrintShiftWariateDic()

    ' シフト→可スタッフ辞書を作成（辞書が取得できなかった場合は終了）
    Dim staff_shift_kahi_dic As Scripting.Dictionary
    Set staff_shift_kahi_dic = CreateShiftWariateDic()
    If staff_shift_kahi_dic Is Nothing Then Exit Sub

    ' 辞書の中身を確認（Debug.Print）
    '--------------------------------------------------------------------------
    ' すべてのシフト名（外側辞書のkey）を走査
    Dim shift_name As Variant
    For Each shift_name In staff_shift_kahi_dic.Keys

        Debug.Print shift_name
        
        ' 対象シフト名の中の全スタッフ名（内側辞書のkey）を走査
        Dim staff_name As Variant
        For Each staff_name In staff_shift_kahi_dic(shift_name).Keys
            ' スタッフ名を出力
            Debug.Print "  "; staff_name
        Next staff_name
    
    Next shift_name

End Sub


Public Function CreateShiftWariateDic() As Scripting.Dictionary

    ' Description
    '   シフト割当表シートを参照し、シフト名→可（〇）スタッフ辞書を作成して返す。
    '   外側辞書：Key=シフト名、value=内側辞書（可スタッフ辞書）
    '
    ' Arguments
    '   (None)
    '
    ' Returns
    '   Dictionary
    '     key   : shift_name (String)
    '     value : Dictionary
    '               key   : staff_name (String)
    '               value : True (Boolean)
    '
    ' References
    '   Microsoft Scripting Runtime


    ' シートの取得
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("シフト割当表")
    
    ' シートの対象範囲を配列として取得
    Dim staff_shift_kahi_tbl As Variant    ' 配列
'    staff_shift_kahi_tbl = ws.UsedRange.Value
    staff_shift_kahi_tbl = GetUsedRangeArray(ws)
    Call DebugPrintArraySize(staff_shift_kahi_tbl, "シフト割当表配列")

    ' 固定仕様（シフト割当表）
    Const STAFF_NAME_COL      As Long = 1   ' 氏名列
    Const SHIFT_START_COL     As Long = 2   ' シフト開始列（B列）
    Const HEADER_ROW          As Long = 1   ' ヘッダ行
    Const DATA_START_ROW      As Long = 2   ' データ開始行

    ' ガード（空配列）
    If IsEmpty(staff_shift_kahi_tbl) Then
        Set CreateShiftWariateDic = Nothing
        Exit Function
    End If

    ' 外側辞書：シフト名 → 可スタッフ辞書 の対応を保持する辞書
    Dim staff_shift_kahi_dic As Scripting.Dictionary
    Set staff_shift_kahi_dic = New Scripting.Dictionary
    
    ' 外側辞書に内側辞書を登録
    '--------------------------------------------------------------------------
    ' 配列を列方向に走査
    Dim shift_col As Long
    For shift_col = SHIFT_START_COL To UBound(staff_shift_kahi_tbl, 2)

        ' シフト名を取得（空欄はスキップ）
        Dim shift_name As String
        shift_name = Trim$(CStr(staff_shift_kahi_tbl(HEADER_ROW, shift_col)))
        If Len(shift_name) = 0 Then GoTo NextShiftCol


        ' 外側辞書に「シフト名」が未登録の場合
        If Not staff_shift_kahi_dic.Exists(shift_name) Then

            ' 内側辞書（可スタッフ辞書）を新規作成
            Dim assignable_staff_dic As Scripting.Dictionary
            Set assignable_staff_dic = New Scripting.Dictionary

            ' 「シフト名」をキー、「可スタッフ辞書」をバリューとして外側辞書に登録
            staff_shift_kahi_dic.Add shift_name, assignable_staff_dic

        End If

        ' 内側辞書にスタッフを登録
        '----------------------------------------------------------------------
        ' 配列を行方向を走査
        Dim staff_row As Long
        For staff_row = DATA_START_ROW To UBound(staff_shift_kahi_tbl, 1)

            ' スタッフ名を取得（空欄は対象外）
            Dim staff_name As String
            staff_name = Trim$(CStr(staff_shift_kahi_tbl(staff_row, STAFF_NAME_COL)))
            If Len(staff_name) = 0 Then GoTo NextStaffRow

            ' クロスポイントの値を取得（○がなければ対象外）
            Dim cell_val As String
            cell_val = Trim$(CStr(staff_shift_kahi_tbl(staff_row, shift_col)))
            If InStr(1, cell_val, "○", vbTextCompare) = 0 Then GoTo NextStaffRow

            ' 内側辞書に未登録の場合、スタッフ名を追加
            If Not staff_shift_kahi_dic(shift_name).Exists(staff_name) Then
                staff_shift_kahi_dic(shift_name).Add staff_name, True
            End If

NextStaffRow:
        Next staff_row

NextShiftCol:
    Next shift_col
    
    ' シフト割当表辞書を返す
    Set CreateShiftWariateDic = staff_shift_kahi_dic

End Function

Option Explicit


' 配列操作関連プロシージャ
'------------------------------------------------------------------------------

Sub DebugPrintArraySize(ByVal arr As Variant, ByVal label As String)

    ' Description
    ' 配列の行要素数・列要素数をイミディエイトウィンドウに出力する
    '
    ' Arguments
    ' arr   : 行列構造を持つ配列
    ' label : デバッグ出力用の識別子（シート名など）


    ' 配列が Empty の場合処理を中断する
    If IsEmpty(arr) Then
        Debug.Print label & " : 配列が Empty です"
        Exit Sub
    End If

    ' 配列の行要素数・列要素数を出力
    Debug.Print label & _
                " 行要素数=" & (UBound(arr, 1) - LBound(arr, 1) + 1) & _
                " 列要素数=" & (UBound(arr, 2) - LBound(arr, 2) + 1)

End Sub


Function GetUsedRangeArray(ByVal ws As Worksheet) As Variant
    
    ' Description
    '   指定されたワークシートの使用範囲を判定し、
    '   Cells(1,1) から最終行・最終列までを配列として返す
    '
    ' Arguments
    '   ws  : 対象となるワークシート
    '
    ' Returns
    '   Variant
    '     ・使用範囲が存在する場合：
    '         Cells(1,1) ～ 最終行・最終列 を格納した 2 次元配列
    '     ・シートにデータが存在しない場合：
    '         Empty
    

    ' シートにデータが存在しない場合は Empty を返す
    If ws.Cells.Find("*") Is Nothing Then
        GetUsedRangeArray = Empty
        MsgBox "シートにデータが存在しません。", vbExclamation
        Exit Function
    End If


    ' 最終行・最終列の取得
    Dim last_row As Long
    Dim last_col As Long

    With ws
        last_row = .Cells.Find( _
                        "*", _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious _
                    ).row

        last_col = .Cells.Find( _
                        "*", _
                        SearchOrder:=xlByColumns, _
                        SearchDirection:=xlPrevious _
                    ).Column
    End With


    ' Return：使用範囲を配列として返す
    GetUsedRangeArray = _
        ws.Range( _
            ws.Cells(1, 1), _
            ws.Cells(last_row, last_col) _
        ).Value

End Function

Option Explicit


' シャッフル関連プロシージャ
'------------------------------------------------------------------------------
Function ShuffleArrayByFisherYates( _
    ByVal src_arr As Variant, _
    ByVal arr_count As Long _
) As Variant

    ' Description
    '   指定された配列の先頭 arr_count 要素を対象に、
    '   フィッシャー・イェーツ法でランダムに並び替えた
    '   新しい配列を返却する
    '
    '   ・元の配列は変更しない
    '   ・arr_count が 0 または 1 の場合は並び替えを行わない
    '
    ' Arguments
    '   src_arr : 並び替え対象の配列（1始まり想定）
    '   arr_count : 有効要素数（先頭から arr_count 件）
    '
    ' Returns
    '   Variant
    '     - ランダムに並び替えられた配列


    ' ガード
    If arr_count <= 1 Then
        ShuffleArrayByFisherYates = src_arr
        Exit Function
    End If


    ' 作業用配列を初期化（有効要素分のみ）
    Dim work_arr() As Variant   ' 作業用配列
    ReDim work_arr(1 To arr_count)


    ' 元配列からコピー
    Dim i As Long
    For i = 1 To arr_count
        work_arr(i) = src_arr(i)
    Next i


    ' フィッシャー・イェーツシャッフル
    For i = arr_count To 2 Step -1

        Dim j As Long
        j = Int(Rnd * i) + 1

        Dim tmp As Variant
        tmp = work_arr(i)
        work_arr(i) = work_arr(j)
        work_arr(j) = tmp

    Next i


    ' Return
    ShuffleArrayByFisherYates = work_arr

End Function